unit ServicesTools;

interface

uses
  SysUtils, Classes, Windows, WinSvc;

procedure InstallService(const Name, DisplayName, Path: string; autostart: boolean= true; interactive: boolean= true);
procedure UninstallService(const Name: string);
procedure StartService(const Name: string);
procedure StopService(const Name: string);
function GetServiceStatus(const Name: string; var Status: TServiceStatus ): boolean;
function WaitForServiceState( const Name: string; CurrentState, WaitState, WaitTime: DWord; var Cancelado: boolean ): boolean;
procedure GetServicesBinaryPath( p: TStrings );
function ServiceBinaryPath( srvname: string ): string;
function GetServiceName( BinaryPath: string ): string;

implementation

uses
  SysConst, Forms;

procedure InstallService(const Name, DisplayName, Path: string; autostart, interactive: boolean);
var
  Svc: Integer;
  SvcMgr: Integer;
  st,sf : integer;
begin
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE);
  if SvcMgr = 0 then RaiseLastWin32Error;
  try
    if autostart then st := SERVICE_AUTO_START
                 else st := SERVICE_DEMAND_START;
    sf := SERVICE_WIN32_OWN_PROCESS;
    if interactive then sf := sf+SERVICE_INTERACTIVE_PROCESS;
    Svc := CreateService(SvcMgr, PChar(Name), PChar(DisplayName),
      SERVICE_ALL_ACCESS, sf, st, SERVICE_ERROR_NORMAL,
      PChar(Path), nil, nil, nil, nil, nil);
    if Svc = 0 then RaiseLastWin32Error;
    CloseServiceHandle(Svc);
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

procedure UninstallService(const Name: string);
var
  Svc: Integer;
  SvcMgr: Integer;
begin
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastWin32Error;
  try
    Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS);
    if Svc = 0 then
    begin
      if (GetLastError<>ERROR_SERVICE_DOES_NOT_EXIST) then RaiseLastWin32Error;
    end;
    try
      if (Svc<>0) and not DeleteService(Svc) then RaiseLastWin32Error;
    finally
      if Svc<>0 then CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

procedure StartService(const Name: string);
var
  Svc: Integer;
  SvcMgr: Integer;
  args: PChar;
begin
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastWin32Error;
  try
    Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS);
    if Svc = 0 then RaiseLastWin32Error;
    try
      args := nil;
      if not WinSvc.StartService(Svc,0,args) then RaiseLastWin32Error;
    finally
      CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

procedure StopService(const Name: string);
var
  Svc: Integer;
  SvcMgr: Integer;
  args: PChar;
  Status: TServiceStatus;
begin
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastWin32Error;
  try
    Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS);
    if Svc = 0 then RaiseLastWin32Error;
    try
      args := nil;
      if not WinSvc.ControlService(Svc,SERVICE_CONTROL_STOP,Status) then RaiseLastWin32Error;
    finally
      CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

function GetServiceStatus(const Name: string; var Status: TServiceStatus ): boolean;
var
  Svc: Integer;
  SvcMgr: Integer;
begin
  result := true;
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastWin32Error;
  try
    Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS);
    if Svc=0 then
    begin
      result := false;
      if (GetLastError<>ERROR_SERVICE_DOES_NOT_EXIST) then RaiseLastWin32Error;
    end;
    try
      if (Svc<>0) and not QueryServiceStatus(Svc,Status) then RaiseLastWin32Error;
    finally
      if Svc<>0 then CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

function WaitForServiceState( const Name: string; CurrentState, WaitState, WaitTime: DWord; var Cancelado: boolean ): boolean;
var
  s : TServiceStatus;
  t : DWord;
begin
  result := false;
  t := GetTickCount;
  if CurrentState<>0 then
    while not Application.Terminated and not Cancelado and
          GetServiceStatus(Name,s) and (s.dwCurrentState=CurrentState) and
          (GetTickCount<t+WaitTime) do
    begin
      Sleep(1000);
      Application.ProcessMessages;
    end
  else
    while not Application.Terminated and not Cancelado and
          GetServiceStatus(Name,s) and (s.dwCurrentState<>WaitState) and
          (GetTickCount<t+WaitTime) do
    begin
      Sleep(1000);
      Application.ProcessMessages;
    end;
  result := s.dwCurrentState=WaitState;
end;

procedure GetServicesBinaryPath( p: TStrings );
var
  Svc: Integer;
  err, SvcMgr, i: Integer;
  args: PChar;
  buffer1, buffer2 : array [1..4192] of byte;
  ss : TEnumServiceStatus absolute buffer1;
  ssa : array [1..1] of TEnumServiceStatus absolute ss;
  sc : TQueryServiceConfig absolute buffer2;
  sr, bn, ResumeHandle : Cardinal;
  Ok, MasDatos : boolean;
  s : string;
begin
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastWin32Error;
  try
    p.BeginUpdate;
    ResumeHandle := 0;
    repeat
      Ok := EnumServicesStatus(SvcMgr, SERVICE_WIN32, SERVICE_ACTIVE+SERVICE_INACTIVE, ss, SizeOf(buffer1), bn, sr, ResumeHandle);
      if not Ok then err := GetLastError
                else err := 0;
      if err=ERROR_MORE_DATA then
      begin
        err := 0; MasDatos := true;
      end
      else if err=0 then MasDatos := false
      else raise Exception.CreateResFmt(@SOSError, [err,SysErrorMessage(err)]);
      if (err=0) and (sr>=1) then
      begin
        for i := 1 to sr do
        begin
          Svc := OpenService(SvcMgr,ssa[i].lpServiceName,SERVICE_ALL_ACCESS);
          if Svc = 0 then RaiseLastWin32Error;
          Ok := QueryServiceConfig(Svc,@sc,SizeOf(buffer2),bn);
          if not Ok then RaiseLastOSError;
          s := Trim(sc.lpBinaryPathName);
          if (length(s)>2) and (s[1]='"') and (s[length(s)]='"') then
            s := Trim(copy(s,2,length(s)-2));
          p.Add(ssa[i].lpServiceName+'='+s);
          CloseServiceHandle(Svc);
        end;
      end;
    until not MasDatos;
    p.EndUpdate;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

function ServiceBinaryPath( srvname: string ): string;
var
  p : TStringList;
begin
  result := '';
  p := TStringList.Create;
  try
    GetServicesBinaryPath(p);
    result := p.Values[srvname];
  finally
    p.Free;
  end;
end;

function GetServiceName( BinaryPath: string ): string;
var
  i : integer;
  d : TStringList;
begin
  result := '';
  d := TStringList.Create;
  try
    GetServicesBinaryPath(d);
    for i := 0 to d.Count-1 do
      if SameText(d.ValueFromIndex[i],BinaryPath) then
      begin
        result := d.Names[i];
        exit;
      end;
  finally
    d.Free;
  end;
end;

end.
